Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue24/ntserv/DemoSv1.Dpr

Text File | 1997-07-04 | 12.8 KB | 356 lines

program DemoSv1;

{==============================================================================}
{ NT service which demonstrates the typical flow sequence for a service. Does  }
{ not use any Delphi classes so we can concentrate on the interaction with the }
{ Service control manager.                                                     }
{                                                                              }
{ This was written by John Chaytor and accompanies an aticle in 'The Delphi    }
{ Magazine'. See that article for a detailed discussion of NT services.        }
{==============================================================================}

Uses
  Windows, SysUtils, Registry, WinSvcX, Demo1Log, Logging;

const
  DemoServiceName        = 'DemoService1';
  DemoServiceDisplayName = 'Demonstation service 1';
  EventRegKey            = 'SYSTEM\CurrentControlSet\Services\EventLog\Application\';

var
  FTerminated: Boolean;
  FPauseStartTicks: LongInt;
  FServiceStatus: TServiceStatus;
  FServicStatusHandle: SERVICE_STATUS_HANDLE;

type
  PCharArray = ^TPCharArray;
  TPCharArray = array[0..0] of PChar;

{------------------------------------------------------------------------------}
procedure DisplaySyntaxOptions;
begin
  WriteLn('');
  WriteLn('Command syntax options :-');
  WriteLn('');
  WriteLn('DemoSv1 INSTALL');
  WriteLn('DemoSv1 I');
  WriteLn('DemoSv1 UNINSTALL');
  WriteLn('DemoSv1 U');
  WriteLn('DemoSv1 VERSION');
  WriteLn('DemoSv1 V');
  WriteLn('');
end;
{------------------------------------------------------------------------------}
procedure LogEvent(Severity: DWord; Id: DWord; Inserts: PCharArray; NumInserts: Integer);
var
  EventSource: THandle;

begin
  EventSource := RegisterEventSource(nil,DemoServiceName);
  try
    ReportEvent(EventSource,Severity,0,Id,nil,NumInserts,Sizeof(FServiceStatus),PChar(Inserts[0]),@FServiceStatus);
  finally
    DeRegisterEventSource(EventSource);
  end;
end;
{------------------------------------------------------------------------------}
procedure InstallService;
Var
  hSCManager: SC_Handle;
  hService: SC_Handle;

  procedure AddEventDetailsToRegistry;
  var
    EventKey: String;

  begin
    EventKey := Format('%s%s',[EventRegKey,DemoServiceName]);
    With TRegistry.Create do
     try
       RootKey := HKEY_LOCAL_MACHINE;
       if OpenKey(EventKey,True) then
         try
           WriteInteger('TypesSupported',EVENTLOG_ERROR_TYPE or EVENTLOG_WARNING_TYPE or EVENTLOG_INFORMATION_TYPE);
           WriteString('EventMessageFile',ParamStr(0));
           WriteLn('Registry has been updated for event logging.');
         except
           DeleteKey(EventKey);
           Raise;
         end
       else
         WriteLn(Format('Failed to open key %s',[EventKey]));
     finally
       Free;
     end;
  end;

Begin
  WriteLn('Installing service...');
  WriteLn(Format('Path to service module is %s',[ParamStr(0)]));
  hSCManager:= OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  If hSCManager <> 0 then
    try
      hService:= CreateService(hSCManager,DemoServiceName,DemoServiceDisplayName,
                                 SERVICE_ALL_ACCESS,SERVICE_WIN32_OWN_PROCESS,
                                 SERVICE_DEMAND_START,SERVICE_ERROR_NORMAL,
                                 PChar(ParamStr(0)),nil,nil,nil,nil,nil);
      if hService <> 0 then
        begin
          WriteLn('Service was installed successfully.');
          AddEventDetailsToRegistry;
        end
      else
        WriteLn(Format('Failed to create the service. Error was ''%s''',[SysErrorMessage(GetLastError)]));
    finally
      CloseServiceHandle(hSCManager)
    end
  else
    WriteLn(Format('Failed to open Service Control Manager. Error was ''%s''',[SysErrorMessage(GetLastError)]));
End;

{------------------------------------------------------------------------------}
procedure UninstallService;
Var
  hSCManager: SC_Handle;
  hService: SC_Handle;

  procedure RemoveEventDetailsFromRegistry;
  var
    EventKey: String;

  begin
    if DemoServiceName <> '' then
      begin
        EventKey := Format('%s%s',[EventRegKey,DemoServiceName]);
        With TRegistry.Create do
         try
           RootKey := HKEY_LOCAL_MACHINE;
           DeleteKey(EventKey);
           WriteLn('Registry details for event logging has been removed.');
         finally
           Free;
         end;
      end
    else
      WriteLn('Service name missing! Registry not updated.');
  end;

Begin
  hSCManager := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  If hSCManager <> 0 then
    try
      hService := OpenService(hSCManager,DemoServiceName,SERVICE_ALL_ACCESS);
      if hService <> 0 then
        try
          if DeleteService(hService) then
            begin
              WriteLn('Service was uninstalled successfully.');
              RemoveEventDetailsFromRegistry;
            end
          else
            WriteLn(Format('Failed to delete service. Error was ''%s''',[SysErrorMessage(GetLastError)]));
        finally
          CloseServiceHandle(hService);
        end
      else
        WriteLn(Format('Failed to open service "%s": Error was ''%s''',[DemoServiceName,SysErrorMessage(GetLastError)]));
    finally
      CloseServiceHandle(hSCManager)
    end
  else
    WriteLn(Format('Failed to open Service control Manager. Error was ''%s''',[SysErrorMessage(GetLastError)]));
End;
{------------------------------------------------------------------------------}
procedure DisplayVersion;
begin
  WriteLn('DemoSv1 version 1.00');
end;
{------------------------------------------------------------------------------}
procedure DemoServiceHandler(Code: Integer); StdCall;
var
  Inserts: array[0..0] of PChar;
  Text: array[0..255] of char;

begin
  case code of
    SERVICE_CONTROL_STOP:
      begin
        With FServiceStatus do
          begin
            dwCurrentState := SERVICE_STOP_PENDING;
            dwWin32ExitCode := 0;
            dwServiceSpecificExitCode := 0;
            dwCheckPoint := 0;
            dwWaitHint := 0;
          end;
      end;
    SERVICE_CONTROL_PAUSE:
      begin
        FPauseStartTicks := GetTickCount;
        FServiceStatus.dwCurrentState := SERVICE_PAUSED;
        LogEvent(EVENTLOG_WARNING_TYPE,DEMO1_SERVICE_PAUSED,nil,0);
      end;
    SERVICE_CONTROL_CONTINUE:
      begin
        FServiceStatus.dwCurrentState := SERVICE_RUNNING;
        Inserts[0] := StrPCopy(Text,IntToStr(GetTickCount - FPauseStartTicks));
        LogEvent(EVENTLOG_INFORMATION_TYPE,DEMO1_SERVICE_CONTINUED,@Inserts,1);
      end;
    SERVICE_CONTROL_INTERROGATE:
      begin
        { Will be set after the case statement. }
      end;
  else
    begin
      Inserts[0] := StrPCopy(Text,IntToStr(Code));
      LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_CODE_INVALID,@Inserts,1);
    end;
  end;
  if not SetServiceStatus(FServicStatusHandle,FServiceStatus) then
    begin
      Inserts[0] := StrPCopy(Text,SysErrorMessage(GetLastError));
      LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_UPDATE_STATUS_FAILED,@Inserts,1);
    end;
  if FServiceStatus.dwCurrentState = SERVICE_STOP_PENDING then
    FTerminated := True;
end;
{------------------------------------------------------------------------------}
Procedure DemoServiceMain(NumArgs: DWord; Args: PCharArray); StdCall;
var
  InitialisedOK: Boolean;
  Inserts: array[0..0] of PChar;
  Text: array[0..255] of char;
  BeepDelay: Integer;

begin
  BeepDelay := 1000;
  if NumArgs > 1 then
    begin
      { Only try and convert last parameter passed }
      try
        Beepdelay := StrToInt(Args^[NumArgs-1]);
      except
        LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_STARTUP_PARM_INVALID,@Args^[NumArgs-1],1);
      end;
      if (BeepDelay < 500) then
        BeepDelay := 500
      else
        if (BeepDelay > 10000) then
          BeepDelay := 10000;
    end;
  FServicStatusHandle := RegisterServiceCtrlHandler(DemoServiceName,@DemoServiceHandler);
  if FServicStatusHandle <> 0 then
    begin
      FillChar(FServiceStatus,sizeof(TServiceStatus),0);
      With FServiceStatus do
        begin
          dwServiceType := SERVICE_WIN32_OWN_PROCESS;
          dwCurrentState := SERVICE_START_PENDING;
          dwControlsAccepted := SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_PAUSE_CONTINUE;
        end;
      { Set status to pending before we do our initilisation }
      if SetServiceStatus(FServicStatusHandle,FServiceStatus) then
        begin
          { Do initialisation here. If it takes > 1 sec you should call SetServiceStatus }
          { passing wait hints and checkpoints to show progress is being made.           }
          { Simulate time taken to initialise }
          Sleep(1000);
          InitialisedOK := True; { We assume initialisation was OK for this demo !!! }
          if InitialisedOK then
            begin
              FServiceStatus.dwCurrentState := SERVICE_RUNNING;
              if SetServiceStatus(FServicStatusHandle,FServiceStatus) then
                begin
                  LogEvent(EVENTLOG_INFORMATION_TYPE,DEMO1_SERVICE_STARTED,nil,0);
                  { Main loop of service process }
                  While not FTerminated do
                    begin
                      Sleep(BeepDelay);
                      if not (FServiceStatus.dwCurrentState = SERVICE_PAUSED) then
                        MessageBeep(0);
                    end;

                  if FServiceStatus.dwCurrentState = SERVICE_STOP_PENDING then
                    begin
                      { Do clenaup processing here }
                      LogEvent(EVENTLOG_INFORMATION_TYPE,DEMO1_SERVICE_ENDED,nil,0);
                      FServiceStatus.dwCurrentState := SERVICE_STOPPED;
                      if not SetServiceStatus(FServicStatusHandle,FServiceStatus) then
                        begin
                          Inserts[0] := StrPCopy(Text,SysErrorMessage(GetLastError));
                          LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_UPDATE_STATUS_FAILED,@Inserts,1);
                        end;
                    end;
                end
              else
                begin
                  Inserts[0] := StrPCopy(Text,IntToStr(GetLastError));
                  LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_UPDATE_STATUS_FAILED,@Inserts,1);
                end;
            end
          else
            With FServiceStatus do
              begin
                LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_FAILED,nil,0);
                dwCurrentState := SERVICE_STOPPED;
                dwWin32ExitCode := 666; { Set a code to indicate reason for failure }
                SetServiceStatus(FServicStatusHandle,FServiceStatus);
              end;
        end
      else
        begin
          Inserts[0] := StrPCopy(Text,SysErrorMessage(GetLastError));
          LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_REGHANDLER_FAILED,@Inserts,1);
        end;
    end
  else
    begin
      Inserts[0] := StrPCopy(Text,SysErrorMessage(GetLastError));
      LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_UPDATE_STATUS_FAILED,@Inserts,1);
    end;
end;
{------------------------------------------------------------------------------}
{ Main() entry point for program                                               }
var
  Param: ShortString;
  ServiceEntryTable: PServiceTableEntry;
  Inserts: array[0..0] of PChar;
  Text: array[0..255] of Char;

begin
  FTerminated := False;
  Param := UpperCase(ParamStr(1));
  if (Param = 'INSTALL') or (Param = 'I')  then
    InstallService
  else
    if (Param = 'UNINSTALL') or (Param = 'U') then
      UninstallService
    else
      if (Param = 'VERSION') or (Param = 'V') then
        DisplayVersion
      else
        if Param = '' then
          begin
            { We should have been called by the SCM, so connect to it. }
            ServiceEntryTable := AllocMem(2*SizeOf(TServiceTableEntry));
            try
              ServiceEntryTable^.lpServiceName:= DemoServiceName;
              ServiceEntryTable^.lpServiceProc:= @DemoServiceMain;
              { The CtrlDispatcher loops round waiting for control requests for    }
              { the service(s) detailed in the ServiceEntryTable array. It will    }
              { not return until the all services in the process terminate (or an  }
              { error has occurred)                                                }
              if not StartServiceCtrlDispatcher(ServiceEntryTable^) then
                begin
                  Inserts[0] := StrPCopy(Text,IntToStr(GetLastError));
                  LogEvent(EVENTLOG_ERROR_TYPE,DEMO1_SERVICE_STARTDISPATCHER_FAILED,@Inserts,1);
                end;
            finally
              FreeMem(ServiceEntryTable);
            end;
          end
        else
          DisplaySyntaxOptions;
end.